home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Misc.sea / Misc / slot-value-using-class.lisp < prev    next >
Encoding:
Text File  |  1993-02-26  |  2.3 KB  |  66 lines  |  [TEXT/CCL2]
  1. ; slot-value-using-class.lisp
  2. ;
  3. ; Slow and simple implementation of SLOT-VALUE-USING-CLASS and friends
  4. ; for MCL 2.0.
  5. ; This slows down all calls to SLOT-VALUE & friends and disables all
  6. ; optimization for DEFCLASS generated accessors.
  7.  
  8. (in-package :ccl)
  9.  
  10. (export '(slot-value-using-class slot-boundp-using-class 
  11.           slot-exists-p-using-class))
  12.  
  13. (eval-when (:compile-toplevel :execute)
  14.   (require "LISPEQU")                   ; for population-data
  15.   )
  16.  
  17. (defvar *slot-value-using-class-inited* nil)
  18.  
  19. (unless *slot-value-using-class-inited*
  20.   (setf (symbol-function 'std-slot-value) #'slot-value
  21.         (symbol-function 'std-set-slot-value) #'set-slot-value
  22.         (symbol-function 'std-slot-boundp) #'slot-boundp
  23.         (symbol-function 'std-slot-exists-p) #'slot-exists-p
  24.         (symbol-function 'std-slot-makunbound) #'slot-makunbound)
  25.   ; This turns off optimization for DEFCLASS generated accessors
  26.   (setq *standard-reader-method-class* nil
  27.         *standard-writer-method-class* nil)
  28.   (dolist (gf (population-data %all-gfs%))
  29.     ; unoptimize existing accessors
  30.     (compute-dcode gf))
  31.   (setq *slot-value-using-class-inited* t))
  32.  
  33. (defmethod slot-value-using-class ((class t) instance slot-name)
  34.   (std-slot-value instance slot-name))
  35.  
  36. (defmethod (setf slot-value-using-class) (value (class t) instance slot-name)
  37.   (std-set-slot-value instance slot-name value))
  38.  
  39. (defmethod slot-boundp-using-class ((class t) instance slot-name)
  40.   (std-slot-boundp instance slot-name))
  41.  
  42. (defmethod slot-exists-p-using-class ((class t) instance slot-name)
  43.   (std-slot-exists-p instance slot-name))
  44.  
  45. (defmethod slot-makunbound-using-class ((class t) instance slot-name)
  46.   (std-slot-makunbound instance slot-name))
  47.  
  48. (let ((*warn-if-redefine* nil)
  49.       (*warn-if-redefine-kernel* nil))
  50.  
  51. (defun slot-value (instance slot-name)
  52.   (slot-value-using-class (class-of instance) instance slot-name))
  53.  
  54. (defun set-slot-value (instance slot-name value)
  55.   (setf (slot-value-using-class (class-of instance) instance slot-name)
  56.         value))
  57.  
  58. (defun slot-boundp (instance slot-name)
  59.   (slot-boundp-using-class (class-of instance) instance slot-name))
  60.  
  61. (defun slot-exists-p (instance slot-name)
  62.   (slot-exists-p-using-class (class-of instance) instance slot-name))
  63.  
  64. (defun slot-makunbound (instance slot-name)
  65.   (slot-makunbound-using-class (class-of instance) instance slot-name))
  66. )